home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xldmem.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  17.4 KB  |  890 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <stdlib.h>
  8. #include <string.h>
  9.  
  10. /* node flags */
  11. #ifdef JGC
  12. #define MARK    0x20
  13. #define LEFT    0x40
  14. #else
  15. #define MARK    1
  16. #define LEFT    2
  17. #endif
  18.  
  19. /* macro to compute the size of a segment */
  20. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  21.  
  22. /* external variables */
  23. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
  24. extern LVAL xlenv,xlfenv,xldenv;
  25. extern char buf[];
  26.  
  27. /* variables local to xldmem.c and xlimage.c */
  28. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  29. int anodes,nsegs,gccalls;
  30. long nnodes,nfree,total;
  31. LVAL fnodes = NIL;
  32.  
  33. /* forward declarations */
  34. #ifdef ANSI
  35. #ifdef JMAC
  36. FORWARD LVAL Newnode(int type);
  37. #else
  38. FORWARD LVAL newnode(int type);
  39. #endif
  40. FORWARD char *stralloc(int size);
  41. FORWARD VOID mark(LVAL ptr);
  42. FORWARD VOID sweep(void);
  43. FORWARD VOID findmem(void);
  44. FORWARD int  addseg(void);
  45. #else
  46. #ifdef JMAC
  47. FORWARD LVAL Newnode();
  48. #else
  49. FORWARD LVAL newnode();
  50. #endif
  51. FORWARD char *stralloc();
  52. FORWARD VOID mark();
  53. FORWARD VOID sweep();
  54. FORWARD VOID findmem();
  55. #endif
  56.  
  57.  
  58. #ifdef JMAC
  59. LVAL _nnode = 0;
  60. FIXTYPE _tfixed = 0;
  61. int _tint = 0;
  62.  
  63. #define    newnode(type) (((_nnode = fnodes) != NIL) ? \
  64.              ((fnodes = cdr(_nnode)), \
  65.               nfree--, \
  66.               (_nnode->n_type = type), \
  67.               rplacd(_nnode,NIL), \
  68.               _nnode) \
  69.              : Newnode(type))
  70.  
  71. #endif
  72.  
  73.  
  74. /* xlminit - initialize the dynamic memory module */
  75. VOID xlminit()
  76. {
  77.     LVAL p;
  78.     int i;
  79.  
  80.     /* initialize our internal variables */
  81.     segs = lastseg = NULL;
  82.     nnodes = nfree = total = 0L;
  83.     nsegs = gccalls = 0;
  84.     anodes = NNODES;
  85.     fnodes = NIL;
  86.  
  87.     /* allocate the fixnum segment */
  88.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  89.         xlfatal("insufficient memory");
  90.  
  91.     /* initialize the fixnum segment */
  92.     p = &fixseg->sg_nodes[0];
  93.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  94.         p->n_type = FIXNUM;
  95.         p->n_fixnum = i;
  96.         ++p;
  97.     }
  98.  
  99.     /* allocate the character segment */
  100.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  101.         xlfatal("insufficient memory");
  102.  
  103.     /* initialize the character segment */
  104.     p = &charseg->sg_nodes[0];
  105.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  106.         p->n_type = CHAR;
  107.         p->n_chcode = i;
  108.         ++p;
  109.     }
  110.  
  111.     /* initialize structures that are marked by the collector */
  112.     obarray = xlenv = xlfenv = xldenv = NIL;
  113.     s_gcflag = s_gchook = NIL;
  114.  
  115.     /* allocate the evaluation stack */
  116.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  117.         xlfatal("insufficient memory");
  118.     xlstack = xlstktop = xlstkbase + EDEPTH;
  119.  
  120.     /* allocate the argument stack */
  121.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  122.         xlfatal("insufficient memory");
  123.     xlargstktop = xlargstkbase + ADEPTH;
  124.     xlfp = xlsp = xlargstkbase;
  125.     *xlsp++ = NIL;
  126. }
  127.  
  128. /* cons - construct a new cons node */
  129. LVAL cons(x,y)
  130.   LVAL x,y;
  131. {
  132.     LVAL nnode;
  133.  
  134.     /* get a free node */
  135.     if ((nnode = fnodes) == NIL) {
  136.         xlstkcheck(2);
  137.         xlprotect(x);
  138.         xlprotect(y);
  139.         findmem();
  140.         if ((nnode = fnodes) == NIL)
  141.             xlabort("insufficient node space");
  142.         xlpop();
  143.         xlpop();
  144.     }
  145.  
  146.     /* unlink the node from the free list */
  147.     fnodes = cdr(nnode);
  148.     --nfree;
  149.  
  150.     /* initialize the new node */
  151.     nnode->n_type = CONS;
  152.     rplaca(nnode,x);
  153.     rplacd(nnode,y);
  154.  
  155.     /* return the new node */
  156.     return (nnode);
  157. }
  158.  
  159. /* cvstring - convert a string to a string node */
  160. LVAL cvstring(str)
  161.   char *str;
  162. {
  163.     LVAL val;
  164.     xlsave1(val);
  165.     val = newnode(STRING);
  166.     val->n_strlen = strlen(str) + 1;
  167.     val->n_string = stralloc(getslength(val));
  168.     strcpy((char *)getstring(val),str);
  169.     xlpop();
  170.     return (val);
  171. }
  172.  
  173. /* newstring - allocate and initialize a new string */
  174. LVAL newstring(size)
  175.   int size;
  176. {
  177.     LVAL val;
  178.     xlsave1(val);
  179.     val = newnode(STRING);
  180.     val->n_strlen = size;
  181.     val->n_string = stralloc(getslength(val));
  182.     strcpy((char *)getstring(val),"");
  183.     xlpop();
  184.     return (val);
  185. }
  186.  
  187. /* cvsymbol - convert a string to a symbol */
  188. LVAL cvsymbol(pname)
  189.   char *pname;
  190. {
  191.     LVAL val;
  192.     xlsave1(val);
  193.     val = newvector(SYMSIZE);
  194.     val->n_type = SYMBOL;
  195.     setvalue(val,s_unbound);
  196.     setfunction(val,s_unbound);
  197.     setpname(val,cvstring(pname));
  198.     xlpop();
  199.     return (val);
  200. }
  201.  
  202. /* cvsubr - convert a function to a subr or fsubr */
  203. #ifdef ANSI
  204. LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
  205. #else
  206. LVAL cvsubr(fcn,type,offset)
  207.   LVAL (*fcn)(); int type,offset;
  208. #endif
  209. {
  210.     LVAL val;
  211.     val = newnode(type);
  212.     val->n_subr = fcn;
  213.     val->n_offset = offset;
  214.     return (val);
  215. }
  216.  
  217. /* cvfile - convert a file pointer to a stream */
  218. LVAL cvfile(fp)
  219.   FILE *fp;
  220. {
  221.     LVAL val;
  222.     val = newnode(STREAM);
  223.     setfile(val,fp);
  224.     setsavech(val,'\0');
  225. #ifdef BETTERIO
  226.     val->n_sflags = 0;
  227. #endif
  228.     return (val);
  229. }
  230.  
  231. #ifdef JMAC
  232.  
  233. /* cvfixnum - convert an integer to a fixnum node */
  234. LVAL Cvfixnum(n)
  235.   FIXTYPE n;
  236. {
  237.     LVAL val;
  238.     val = newnode(FIXNUM);
  239.     val->n_fixnum = n;
  240.     return (val);
  241. }
  242. #else
  243. /* cvfixnum - convert an integer to a fixnum node */
  244. LVAL cvfixnum(n)
  245.   FIXTYPE n;
  246. {
  247.     LVAL val;
  248.     if (n >= SFIXMIN && n <= SFIXMAX)
  249.         return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  250.     val = newnode(FIXNUM);
  251.     val->n_fixnum = n;
  252.     return (val);
  253. }
  254. #endif
  255.  
  256. /* cvflonum - convert a floating point number to a flonum node */
  257. LVAL cvflonum(n)
  258.   FLOTYPE n;
  259. {
  260.     LVAL val;
  261.     val = newnode(FLONUM);
  262.     val->n_flonum = n;
  263.     return (val);
  264. }
  265.  
  266. /* cvchar - convert an integer to a character node */
  267. #ifdef JMAC
  268. LVAL Cvchar(n)
  269.   int n;
  270. {
  271.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  272.     return(NIL);    /* never executed */
  273. }
  274. #else
  275. LVAL cvchar(n)
  276.   int n;
  277. {
  278.     if (n >= CHARMIN && n <= CHARMAX)
  279.         return (&charseg->sg_nodes[n-CHARMIN]);
  280.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  281.     return 0;    /* never executed but gets rid of warning message */
  282. }
  283. #endif
  284.  
  285. /* newustream - create a new unnamed stream */
  286. LVAL newustream()
  287. {
  288.     LVAL val;
  289.     val = newnode(USTREAM);
  290.     sethead(val,NIL);
  291.     settail(val,NIL);
  292.     return (val);
  293. }
  294.  
  295. /* newobject - allocate and initialize a new object */
  296. LVAL newobject(cls,size)
  297.   LVAL cls; int size;
  298. {
  299.     LVAL val;
  300.     val = newvector(size+1);
  301.     val->n_type = OBJECT;
  302.     setelement(val,0,cls);
  303.     return (val);
  304. }
  305.  
  306. /* newclosure - allocate and initialize a new closure */
  307. LVAL newclosure(name,type,env,fenv)
  308.   LVAL name,type,env,fenv;
  309. {
  310.     LVAL val;
  311.     val = newvector(CLOSIZE);
  312.     val->n_type = CLOSURE;
  313.     setname(val,name);
  314.     settype(val,type);
  315.     setenvi(val,env);
  316.     setfenv(val,fenv);
  317.     return (val);
  318. }
  319.  
  320. #ifdef STRUCTS
  321. /* newstruct - allocate and initialize a new structure node */
  322. LVAL newstruct(type,size)
  323.  LVAL type; int size;
  324. {
  325.     LVAL val;
  326.     val = newvector(size+1);
  327.     val->n_type = STRUCT;
  328.     setelement(val,0,type);
  329.     return (val);
  330. }
  331. #endif
  332.  
  333.  
  334. /* newvector - allocate and initialize a new vector node */
  335. LVAL newvector(size)
  336.   int size;
  337. {
  338.     LVAL vect;
  339.     int bsize;
  340.     xlsave1(vect);
  341.     vect = newnode(VECTOR);
  342.     vect->n_vsize = 0;
  343.     if ((bsize = size * sizeof(LVAL)) != 0) {
  344.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  345.             findmem();
  346.             if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  347.                 xlfail("insufficient vector space");
  348.         }
  349.         vect->n_vsize = size;
  350.         total += (long) bsize;
  351.     }
  352.     xlpop();
  353.     return (vect);
  354. }
  355.  
  356. /* newnode - allocate a new node */
  357. #ifdef JMAC
  358. LOCAL LVAL Newnode(type)
  359.   int type;
  360. {
  361.     LVAL nnode;
  362.  
  363.     /* get a free node */
  364.     findmem();
  365.     if ((nnode = fnodes) == NIL)
  366.         xlabort("insufficient node space");
  367.  
  368.     /* unlink the node from the free list */
  369.     fnodes = cdr(nnode);
  370.     nfree -= 1L;
  371.  
  372.     /* initialize the new node */
  373.     nnode->n_type = type;
  374.     rplacd(nnode,NIL);
  375.  
  376.     /* return the new node */
  377.     return (nnode);
  378. }
  379. #else
  380. LOCAL LVAL newnode(type)
  381.   int type;
  382. {
  383.     LVAL nnode;
  384.  
  385.     /* get a free node */
  386.     if ((nnode = fnodes) == NIL) {
  387.         findmem();
  388.         if ((nnode = fnodes) == NIL)
  389.             xlabort("insufficient node space");
  390.     }
  391.  
  392.     /* unlink the node from the free list */
  393.     fnodes = cdr(nnode);
  394.     nfree -= 1L;
  395.  
  396.     /* initialize the new node */
  397.     nnode->n_type = type;
  398.     rplacd(nnode,NIL);
  399.  
  400.     /* return the new node */
  401.     return (nnode);
  402. }
  403. #endif
  404.  
  405. /* stralloc - allocate memory for a string adding a byte for the terminator */
  406. LOCAL char *stralloc(size)
  407.   int size;
  408. {
  409.     char *sptr;
  410.  
  411.     /* allocate memory for the string copy */
  412.     if ((sptr = malloc(size)) == NULL) {
  413.         gc();  
  414.         if ((sptr = malloc(size)) == NULL)
  415.             xlfail("insufficient string space");
  416.     }
  417.     total += (long)size;
  418.  
  419.     /* return the new string memory */
  420.     return (sptr);
  421. }
  422.  
  423. /* findmem - find more memory by collecting then expanding */
  424. LOCAL VOID findmem()
  425. {
  426.     gc();
  427.     if (nfree < (long)anodes)
  428.         addseg();
  429. }
  430.  
  431. /* gc - garbage collect (only called here and in xlimage.c) */
  432. VOID gc()
  433. {
  434.     register LVAL **p,*ap,tmp;
  435.     char buf[STRMAX+1];
  436.     LVAL *newfp,fun;
  437.  
  438.     /* print the start of the gc message */
  439.     if (s_gcflag && getvalue(s_gcflag)) {
  440.         sprintf(buf,"[ gc: total %ld, ",nnodes);
  441.         stdputstr(buf);
  442.     }
  443.  
  444.     /* mark the obarray, the argument list and the current environment */
  445.     if (obarray)
  446.         mark(obarray);
  447.     if (xlenv)
  448.         mark(xlenv);
  449.     if (xlfenv)
  450.         mark(xlfenv);
  451.     if (xldenv)
  452.         mark(xldenv);
  453.  
  454.     /* mark the evaluation stack */
  455.     for (p = xlstack; p < xlstktop; ++p)
  456.         if ((tmp = **p) != 0)
  457.             mark(tmp);
  458.  
  459.     /* mark the argument stack */
  460.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  461.         if ((tmp = *ap) != 0)
  462.             mark(tmp);
  463.  
  464.     /* sweep memory collecting all unmarked nodes */
  465.     sweep();
  466.  
  467.     /* count the gc call */
  468.     ++gccalls;
  469.  
  470.     /* call the *gc-hook* if necessary */
  471.     if (s_gchook && ((fun = getvalue(s_gchook)) != 0) ) {
  472.         newfp = xlsp;
  473.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  474.         pusharg(fun);
  475.         pusharg(cvfixnum((FIXTYPE)2));
  476.         pusharg(cvfixnum((FIXTYPE)nnodes));
  477.         pusharg(cvfixnum((FIXTYPE)nfree));
  478.         xlfp = newfp;
  479.         xlapply(2);
  480.     }
  481.  
  482.     /* print the end of the gc message */
  483.     if (s_gcflag && getvalue(s_gcflag)) {
  484.         sprintf(buf,"%ld free ]\n",nfree);
  485.         stdputstr(buf);
  486.     }
  487. }
  488.  
  489. /* mark - mark all accessible nodes */
  490. LOCAL VOID mark(ptr)
  491.   LVAL ptr;
  492. {
  493.     register LVAL this,prev,tmp;
  494. #ifdef JGC
  495.     int i,n;
  496. #else
  497.     int type,i,n;
  498. #endif
  499.     /* initialize */
  500.     prev = NIL;
  501.     this = ptr;
  502.  
  503.     /* mark this list */
  504.     for (;;) {
  505. #ifdef JGC
  506.   
  507. /* descend as far as we can */
  508.     while (!(this->n_type & MARK))
  509.   
  510.         /* check cons and symbol nodes */
  511.         if (((i = (this->n_type |= MARK) & TYPEFIELD) == CONS)||
  512.             (i == USTREAM)) {
  513.             if ((tmp = car(this)) != 0) {
  514.                 this->n_type |= LEFT;
  515.                 rplaca(this,prev);
  516.             }
  517.             else if ((tmp = cdr(this)) != 0)
  518.                 rplacd(this,prev);
  519.             else                /* both sides nil */
  520.                 break;
  521.             prev = this;            /* step down the branch */
  522.             this = tmp;
  523.         }
  524.         else {
  525.             if ((i & ARRAY) != 0)
  526.                 for (i = 0, n = getsize(this); i < n;)
  527.                     if ((tmp = getelement(this,i++)) != 0)
  528.                         if ((tmp->n_type & (ARRAY|MARK)) == ARRAY ||
  529.                             tmp->n_type == CONS ||
  530.                             tmp->n_type == USTREAM)
  531.                             mark(tmp);
  532.                         else tmp->n_type |= MARK;
  533.                         break;
  534.         }
  535.  
  536.         /* backup to a point where we can continue descending */
  537.         for (;;)
  538.  
  539.             /* make sure there is a previous node */
  540.             if (prev) {
  541.                 if (prev->n_type & LEFT) {        /* came from left side */
  542.                     prev->n_type &= ~LEFT;
  543.                     tmp = car(prev);
  544.                     rplaca(prev,this);
  545.                     if ((this = cdr(prev)) != 0) {
  546.                         rplacd(prev,tmp);                        
  547.                         break;
  548.                     }
  549.                 }
  550.                 else {                            /* came from right side */
  551.                     tmp = cdr(prev);
  552.                     rplacd(prev,this);
  553.                 }
  554.                 this = prev;                    /* step back up the branch */
  555.                 prev = tmp;
  556.             }
  557. #else
  558.         /* descend as far as we can */
  559.         while (!(this->n_flags & MARK))
  560.  
  561.             /* check cons and symbol nodes */
  562.             if ((type = ntype(this)) == CONS || type == USTREAM ) { /* TAA fix*/
  563.                 if ((tmp = car(this)) != 0) {
  564.                     this->n_flags |= MARK|LEFT;
  565.                     rplaca(this,prev);
  566.                 }
  567.                 else if ((tmp = cdr(this)) != 0) {
  568.                     this->n_flags |= MARK;
  569.                     rplacd(this,prev);
  570.                 }
  571.                 else {                            /* both sides nil */
  572.                     this->n_flags |= MARK;
  573.                     break;
  574.                 }
  575.                 prev = this;                    /* step down the branch */
  576.                 this = tmp;
  577.             }
  578.  
  579.             /* mark other node types */
  580.             else {
  581.                 this->n_flags |= MARK;
  582.                 switch (type) {
  583.                 case SYMBOL:
  584.                 case OBJECT:
  585.                 case VECTOR:
  586.                 case CLOSURE:
  587. #ifdef STRUCTS
  588.                 case STRUCT:
  589. #endif
  590.                     for (i = 0, n = getsize(this); --n >= 0; ++i)
  591.                         if ((tmp = getelement(this,i)) != 0)
  592.                             mark(tmp);
  593.                     break;
  594.                 }
  595.                 break;
  596.             }
  597.  
  598.         /* backup to a point where we can continue descending */
  599.         for (;;)
  600.  
  601.             /* make sure there is a previous node */
  602.             if (prev) {
  603.                 if (prev->n_flags & LEFT) {        /* came from left side */
  604.                     prev->n_flags &= ~LEFT;
  605.                     tmp = car(prev);
  606.                     rplaca(prev,this);
  607.                     if ((this = cdr(prev)) != 0) {
  608.                         rplacd(prev,tmp);                        
  609.                         break;
  610.                     }
  611.                 }
  612.                 else {                            /* came from right side */
  613.                     tmp = cdr(prev);
  614.                     rplacd(prev,this);
  615.                 }
  616.                 this = prev;                    /* step back up the branch */
  617.                 prev = tmp;
  618.         }
  619. #endif
  620.  
  621.             /* no previous node, must be done */
  622.             else
  623.                 return;
  624.     }
  625. }
  626.  
  627. /* sweep - sweep all unmarked nodes and add them to the free list */
  628. LOCAL VOID sweep()
  629. {
  630.     SEGMENT *seg;
  631.     LVAL p;
  632.     int n;
  633.  
  634.     /* empty the free list */
  635.     fnodes = NIL;
  636.     nfree = 0L;
  637.  
  638.     /* add all unmarked nodes */
  639.     for (seg = segs; seg; seg = seg->sg_next) {
  640.         if (seg == fixseg || seg == charseg)
  641. #ifdef JGC
  642.             {
  643.             /* remove marks from segments */
  644.             p = &seg->sg_nodes[0];
  645.             for (n = seg->sg_size; --n >= 0;)
  646.                 (p++)->n_type &= ~MARK;
  647.             continue;
  648.         }
  649. #else
  650.             continue; /* don't sweep fixed segments */
  651. #endif
  652.         p = &seg->sg_nodes[0];
  653. #ifdef JGC
  654.         for (n = seg->sg_size; --n >= 0;)
  655.             if (p->n_type & MARK)
  656.                 (p++)->n_type &= ~MARK;
  657.             else {
  658.                 switch (ntype(p)&TYPEFIELD) {
  659. #else
  660.         for (n = seg->sg_size; --n >= 0; ++p)
  661.             if (!(p->n_flags & MARK)) {
  662.                 switch (ntype(p)) {
  663. #endif
  664.                 case STRING:
  665.                         if (getstring(p) != NULL) {
  666.                             total -= (long)getslength(p);
  667.                             free(getstring(p));
  668.                         }
  669.                         break;
  670.                 case STREAM:
  671.                         if (getfile(p) 
  672.                             && getfile(p) != stdin
  673.                             && getfile(p) != stdout
  674.                             && getfile(p) != stderr)/* taa fix - dont close stdio */
  675.                             osclose(getfile(p));
  676.                         break;
  677.                 case SYMBOL:
  678.                 case OBJECT:
  679.                 case VECTOR:
  680.                 case CLOSURE:
  681. #ifdef STRUCTS
  682.                 case STRUCT:
  683. #endif
  684.                         if (p->n_vsize) {
  685.                             total -= (long) (p->n_vsize * sizeof(LVAL));
  686.                             free(p->n_vdata);
  687.                         }
  688.                         break;
  689.                 }
  690.                 p->n_type = FREE;
  691.                 rplaca(p,NIL);
  692.                 rplacd(p,fnodes);
  693. #ifdef JGC
  694.                 fnodes = p++;
  695.                 nfree++;
  696.             }
  697. #else
  698.                 fnodes = p;
  699.                 nfree += 1L;
  700.             }
  701.             else
  702.                 p->n_flags &= ~MARK;
  703. #endif
  704.     }
  705. }
  706.  
  707. /* addseg - add a segment to the available memory */
  708. LOCAL int addseg()
  709. {
  710.     SEGMENT *newseg;
  711.     LVAL p;
  712.     int n;
  713.  
  714.     /* allocate the new segment */
  715.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  716.         return (FALSE);
  717.  
  718.     /* add each new node to the free list */
  719.     p = &newseg->sg_nodes[0];
  720.     for (n = anodes; --n >= 0; ++p) {
  721.         rplacd(p,fnodes);
  722.         fnodes = p;
  723.     }
  724.     
  725.     /* return successfully */
  726.     return (TRUE);
  727. }
  728.  
  729. /* newsegment - create a new segment (only called here and in xlimage.c) */
  730. SEGMENT *newsegment(n)
  731.   int n;
  732. {
  733.     SEGMENT *newseg;
  734.  
  735.     /* allocate the new segment */
  736.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  737.         return (NULL);
  738.  
  739.     /* initialize the new segment */
  740.     newseg->sg_size = n;
  741.     newseg->sg_next = NULL;
  742.     if (segs)
  743.         lastseg->sg_next = newseg;
  744.     else
  745.         segs = newseg;
  746.     lastseg = newseg;
  747.  
  748.     /* update the statistics */
  749.     total += (long)segsize(n);
  750.     nnodes += (long)n;
  751.     nfree += (long)n;
  752.     ++nsegs;
  753.  
  754.     /* return the new segment */
  755.     return (newseg);
  756. }
  757.  
  758. /* stats - print memory statistics */
  759. #ifdef ANSI
  760. static void stats(void)
  761. #else
  762. LOCAL VOID stats()
  763. #endif
  764. {
  765.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  766.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  767.     sprintf(buf,"Segments:    %d\n",nsegs);      stdputstr(buf);
  768.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  769.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  770.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  771. }
  772.  
  773. /* xgc - xlisp function to force garbage collection */
  774. LVAL xgc()
  775. {
  776.     /* make sure there aren't any arguments */
  777.     xllastarg();
  778.  
  779.     /* garbage collect */
  780.     gc();
  781.  
  782.     /* return nil */
  783.     return (NIL);
  784. }
  785.  
  786. /* xexpand - xlisp function to force memory expansion */
  787. LVAL xexpand()
  788. {
  789.     LVAL num;
  790.     FIXTYPE n,i;
  791.  
  792.     /* get the new number to allocate */
  793.     if (moreargs()) {
  794.         num = xlgafixnum();
  795.         n = getfixnum(num);
  796.     }
  797.     else
  798.         n = 1;
  799.     xllastarg();
  800.  
  801.     /* allocate more segments */
  802.     for (i = 0; i < n; i++)
  803.         if (!addseg())
  804.             break;
  805.  
  806.     /* return the number of segments added */
  807.     return (cvfixnum((FIXTYPE)i));
  808. }
  809.  
  810. /* xalloc - xlisp function to set the number of nodes to allocate */
  811. LVAL xalloc()
  812. {
  813.     int n,oldn;
  814.     LVAL num;
  815.  
  816.     /* get the new number to allocate */
  817.     num = xlgafixnum();
  818.     n = (int) getfixnum(num);    /* if it doesn't fit in an int, we are in
  819.                                     trouble anyway! */
  820.  
  821.     /* make sure there aren't any more arguments */
  822.     xllastarg();
  823.  
  824.     /* set the new number of nodes to allocate */
  825.     oldn = anodes;
  826.     anodes = n;
  827.  
  828.     /* return the old number */
  829.     return (cvfixnum((FIXTYPE)oldn));
  830. }
  831.  
  832. /* xmem - xlisp function to print memory statistics */
  833. LVAL xmem()
  834. {
  835.     /* allow one argument for compatiblity with common lisp */
  836.     if (moreargs()) xlgetarg();
  837.     xllastarg();
  838.  
  839.     /* print the statistics */
  840.     stats();
  841.  
  842.     /* return nil */
  843.     return (NIL);
  844. }
  845.  
  846. #ifdef SAVERESTORE
  847. /* xsave - save the memory image */
  848. LVAL xsave()
  849. {
  850.     char *name;
  851.  
  852.     /* get the file name, verbose flag and print flag */
  853.     name = getstring(xlgetfname());
  854.     xllastarg();
  855.  
  856.     /* save the memory image */
  857.     return (xlisave(name) ? true : NIL);
  858. }
  859.  
  860. #ifdef MSC6
  861. /* no optimization which interferes with setjmp */
  862. #pragma optimize("elg",off)
  863. #endif
  864.  
  865. /* xrestore - restore a saved memory image */
  866. LVAL xrestore()
  867. {
  868.     extern jmp_buf top_level;
  869.     char *name;
  870.  
  871.     /* get the file name, verbose flag and print flag */
  872.     name = getstring(xlgetfname());
  873.     xllastarg();
  874.  
  875.     /* restore the saved memory image */
  876.     if (!xlirestore(name))
  877.         return (NIL);
  878.  
  879.     /* return directly to the top level */
  880.     stdputstr("[ returning to the top level ]\n");
  881.     longjmp(top_level,1);
  882.     return (NIL);    /* never executed, but avoids warning message */
  883. }
  884. #ifdef MSC6
  885. #pragma optimize("",on)
  886. #endif
  887.  
  888. #endif
  889.  
  890.